Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/getfil2r/form1.frm

Visual Basic Form | 1999-08-16 | 17.6 KB | 612 lines

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   5010
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   8970
   LinkTopic       =   "Form1"
   ScaleHeight     =   5010
   ScaleWidth      =   8970
   StartUpPosition =   3  'Windows Default
   Begin VB.TextBox txtNumPoints
      Height          =   285
      Left            =   1755
      TabIndex        =   18
      Text            =   "1024"
      Top             =   4050
      Width           =   735
   End
   Begin VB.Frame Frame3
      Caption         =   "Smoothing Algorithm"
      Height          =   1140
      Left            =   135
      TabIndex        =   15
      Top             =   90
      Width           =   2850
      Begin VB.OptionButton Option1
         Caption         =   "FFT"
         Height          =   195
         Index           =   1
         Left            =   225
         TabIndex        =   17
         Top             =   720
         Width           =   2040
      End
      Begin VB.OptionButton Option1
         Caption         =   "Savitzky-Golay"
         Height          =   375
         Index           =   0
         Left            =   225
         TabIndex        =   16
         Top             =   270
         Width           =   2040
      End
   End
   Begin VB.TextBox txtRandom
      Height          =   330
      Left            =   7200
      TabIndex        =   11
      Text            =   "1"
      Top             =   4545
      Width           =   510
   End
   Begin VB.CommandButton CmdCreateData
      Caption         =   "Reset Data"
      Height          =   375
      Left            =   3375
      TabIndex        =   1
      Top             =   4500
      Width           =   2445
   End
   Begin VB.PictureBox Pic1
      BackColor       =   &H80000005&
      Height          =   4200
      Left            =   3195
      ScaleHeight     =   4140
      ScaleWidth      =   5535
      TabIndex        =   0
      Top             =   135
      Width           =   5595
   End
   Begin VB.Frame Frame2
      Caption         =   "FFT Smooth"
      Height          =   2490
      Left            =   135
      TabIndex        =   7
      Top             =   1350
      Width           =   2895
      Begin VB.HScrollBar HScroll1
         Height          =   285
         Left            =   135
         Max             =   1024
         Min             =   2
         TabIndex        =   8
         Top             =   1440
         Value           =   100
         Width           =   2535
      End
      Begin VB.Label Label4
         Caption         =   "Move the scroll bar to smooth using the FFT algorithm"
         Height          =   510
         Left            =   315
         TabIndex        =   14
         Top             =   405
         Width           =   2355
      End
      Begin VB.Label Lblfft
         AutoSize        =   -1  'True
         Caption         =   "Frequency Cut-Off:  2 %"
         Height          =   195
         Left            =   585
         TabIndex        =   9
         Top             =   1125
         Width           =   1680
      End
   End
   Begin VB.Frame Frame1
      Caption         =   "Savitzky-Golay Smoothing"
      Height          =   2490
      Left            =   135
      TabIndex        =   2
      Top             =   1350
      Width           =   2895
      Begin VB.CommandButton CmdSG2
         Caption         =   "Cumulative Smoothing"
         Enabled         =   0   'False
         Height          =   375
         Left            =   180
         TabIndex        =   12
         Top             =   1935
         Width           =   2175
      End
      Begin VB.CommandButton Cmdsg1
         Caption         =   "Smooth Data"
         Height          =   375
         Left            =   180
         TabIndex        =   6
         Top             =   1440
         Width           =   2175
      End
      Begin VB.ComboBox CboSavGol
         Height          =   315
         Left            =   1665
         Style           =   2  'Dropdown List
         TabIndex        =   5
         Top             =   405
         Width           =   1095
      End
      Begin VB.CheckBox ChkLog
         Caption         =   "Log Data"
         Height          =   375
         Left            =   180
         TabIndex        =   4
         ToolTipText     =   "Useful for positive data, spanning several orders of magnitude"
         Top             =   855
         Width           =   1905
      End
      Begin VB.Label Label1
         Caption         =   "Smoothing Window:"
         Height          =   285
         Left            =   180
         TabIndex        =   3
         Top             =   450
         Width           =   1590
      End
   End
   Begin VB.Label Label6
      Caption         =   "For speed in FFT, use a power of 2 for the number of points"
      Height          =   420
      Left            =   45
      TabIndex        =   20
      Top             =   4500
      Width           =   2805
   End
   Begin VB.Label Label5
      Caption         =   "Number of Points:"
      Height          =   240
      Left            =   270
      TabIndex        =   19
      Top             =   4095
      Width           =   1680
   End
   Begin VB.Label Label3
      Caption         =   "(1 - 5)"
      Height          =   330
      Left            =   7830
      TabIndex        =   13
      Top             =   4590
      Width           =   915
   End
   Begin VB.Label Label2
      Caption         =   "Randomness:"
      Height          =   330
      Left            =   6075
      TabIndex        =   10
      Top             =   4590
      Width           =   1680
   End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'Dynamic data arrays
Dim DataX() As Double
Dim DataY() As Double
Dim SmoothedY() As Double
Dim DataI() As Double
Private Const PI As Double = 3.14159265358979
Dim NP As Integer
Dim SmoothCount As Integer
'The matrix for the Savitzky-Golay Coefficents
'These are filled in the form load event
Dim SGCoef(1 To 11, 0 To 13) As Integer
Private Sub CmdCreateData_Click()
Dim i As Integer
Dim Ymin As Double, Ymax As Double
Dim RandFactor As Double
Randomize
Ymin = 0
Ymax = 0
RandFactor = Val(txtRandom)
NP = Val(txtNumPoints)
HScroll1.Max = NP
ReDim DataX(1 To NP)
ReDim DataY(1 To NP)
ReDim SmoothedY(1 To NP)
ReDim DataI(1 To NP)
For i = 1 To NP
  DataX(i) = i
  DataI(i) = 0
  DataY(i) = Sin(i / NP * 4 * PI) + 0.5 * Sin(i / NP * 40 * PI) + RandFactor * Rnd + 4
  If DataY(i) > Ymax Then Ymax = DataY(i)
  If DataY(i) < Ymin Then Ymin = DataY(i)
Pic1.ScaleLeft = 0
Pic1.ScaleWidth = NP
Pic1.ScaleTop = Ymax + Ymax * 0.1
Pic1.ScaleHeight = ((Ymax - Ymin)) * -1
GraphData DataY
SmoothCount = 0
If Option1(0).Value Then
  Me.Caption = "Savitzky-Golay Smoothing"
  Me.Caption = "FFT Smoothing"
End If
CmdSG2.Enabled = False
HScroll1.SmallChange = NP / 100
HScroll1.LargeChange = NP / 20
End Sub
Private Sub Cmdsg1_Click()
Call SavGolSmooth(CboSavGol.ListIndex + 2, False)
Me.Caption = "Smoothed " & SmoothCount & " time"
GraphData SmoothedY
End Sub
Private Sub CmdSG2_Click()
Call SavGolSmooth(CboSavGol.ListIndex + 2, True)
Me.Caption = "Smoothed " & SmoothCount & " times"
GraphData SmoothedY()
End Sub
Private Sub Form_Activate()
Option1(0).Value = True
End Sub
Private Sub Form_Load()
CboSavGol.Clear
CboSavGol.AddItem "5 point"
CboSavGol.AddItem "7 point"
CboSavGol.AddItem "9 point"
CboSavGol.AddItem "11 point"
CboSavGol.AddItem "13 point"
CboSavGol.AddItem "15 point"
CboSavGol.AddItem "17 point"
CboSavGol.AddItem "19 point"
CboSavGol.AddItem "21 point"
CboSavGol.AddItem "23 point"
CboSavGol.AddItem "25 point"
CboSavGol.ListIndex = 0
'Set the Smoothing Coefficients for Savitzky-Golay
'The zeroth value is the normalization factor
SGCoef(1, 1) = 17
SGCoef(1, 2) = 12
SGCoef(1, 3) = -3
SGCoef(1, 0) = 35
SGCoef(2, 1) = 7
SGCoef(2, 2) = 6
SGCoef(2, 3) = 3
SGCoef(2, 4) = -2
SGCoef(2, 0) = 21
SGCoef(3, 1) = 59
SGCoef(3, 2) = 54
SGCoef(3, 3) = 39
SGCoef(3, 4) = 14
SGCoef(3, 5) = -21
SGCoef(3, 0) = 231
SGCoef(4, 1) = 89
SGCoef(4, 2) = 84
SGCoef(4, 3) = 69
SGCoef(4, 4) = 44
SGCoef(4, 5) = 9
SGCoef(4, 6) = -36
SGCoef(4, 0) = 429
SGCoef(5, 1) = 25
SGCoef(5, 2) = 24
SGCoef(5, 3) = 21
SGCoef(5, 4) = 16
SGCoef(5, 5) = 9
SGCoef(5, 6) = 0
SGCoef(5, 7) = -11
SGCoef(5, 0) = 143
SGCoef(6, 1) = 167
SGCoef(6, 2) = 162
SGCoef(6, 3) = 147
SGCoef(6, 4) = 122
SGCoef(6, 5) = 87
SGCoef(6, 6) = 42
SGCoef(6, 7) = -13
SGCoef(6, 8) = -78
SGCoef(6, 0) = 1105
SGCoef(7, 1) = 43
SGCoef(7, 2) = 42
SGCoef(7, 3) = 39
SGCoef(7, 4) = 34
SGCoef(7, 5) = 27
SGCoef(7, 6) = 18
SGCoef(7, 7) = 7
SGCoef(7, 8) = -6
SGCoef(7, 9) = -21
SGCoef(7, 0) = 323
SGCoef(8, 1) = 269
SGCoef(8, 2) = 264
SGCoef(8, 3) = 249
SGCoef(8, 4) = 224
SGCoef(8, 5) = 189
SGCoef(8, 6) = 144
SGCoef(8, 7) = 89
SGCoef(8, 8) = 24
SGCoef(8, 9) = -51
SGCoef(8, 10) = -136
SGCoef(8, 0) = 2261
SGCoef(9, 1) = 329
SGCoef(9, 2) = 324
SGCoef(9, 3) = 309
SGCoef(9, 4) = 284
SGCoef(9, 5) = 249
SGCoef(9, 6) = 204
SGCoef(9, 7) = 149
SGCoef(9, 8) = 84
SGCoef(9, 9) = 9
SGCoef(9, 10) = -76
SGCoef(9, 11) = -171
SGCoef(9, 0) = 3059
SGCoef(10, 1) = 79
SGCoef(10, 2) = 78
SGCoef(10, 3) = 75
SGCoef(10, 4) = 70
SGCoef(10, 5) = 63
SGCoef(10, 6) = 54
SGCoef(10, 7) = 43
SGCoef(10, 8) = 30
SGCoef(10, 9) = 15
SGCoef(10, 10) = -2
SGCoef(10, 11) = -21
SGCoef(10, 12) = -42
SGCoef(10, 0) = 806
SGCoef(11, 1) = 467
SGCoef(11, 2) = 462
SGCoef(11, 3) = 447
SGCoef(11, 4) = 422
SGCoef(11, 5) = 387
SGCoef(11, 6) = 322
SGCoef(11, 7) = 287
SGCoef(11, 8) = 222
SGCoef(11, 9) = 147
SGCoef(11, 10) = 62
SGCoef(11, 11) = -33
SGCoef(11, 12) = -138
SGCoef(11, 13) = -253
SGCoef(11, 0) = 5135
End Sub
Private Sub HScroll1_Change()
Dim Keep As Integer
Dim Power2 As Integer
Dim tr() As Double, ti() As Double
Dim i As Integer, J As Integer
Dim NP_FFT As Integer
Dim AvgVal As Double
Lblfft = "Frequency Cut-off:  " & Format((HScroll1.Value / NP) * 100, "0") & " %"
'This procedure calculates the correct power of 2 to use, and calls the FFT
'routine as neccesary. The FFT algorithm always smooths the original data
'There is no cumulative smoothing
For i = 1 To 14
  If 2 ^ i >= NP Then
    Power2 = i
    Exit For
  End If
Next i
NP_FFT = 2 ^ Power2
ReDim tr(1 To NP_FFT)
ReDim ti(1 To NP_FFT)
If NP_FFT = NP Then
  tr = DataY
  ti = DataI
  'We have to pad the array - I choose to pad the array with the average
  'of the first and last data values
  AvgVal = (DataY(i) + DataY(NP)) / 2
   For i = 1 To NP_FFT
   If i <= NP Then
     tr(i) = DataY(i)
     ti(i) = 0
   Else
     tr(i) = AvgVal
     ti(i) = 0
   End If
 Next i
End If
  Keep = CInt(HScroll1.Value / 2)
  'First call to get the imaginary data array sorted out
  Call FFT(tr, ti, Power2, -1)

  For i = 1 + Keep To NP_FFT - Keep
    tr(i) = 0
    ti(i) = 0
  Next
  'This call will give us the smoothed data
  Call FFT(tr, ti, Power2, 1)
  'transfer FFT data to our smoothed Array  (deleted for speed!)
  ReDim Preserve tr(1 To NP)
  SmoothedY = tr
  GraphData SmoothedY  'Graph the smoothed data
End Sub
Public Sub GraphData(Data() As Double)
On Error Resume Next
Dim i As Integer
Pic1.Cls
For i = 2 To UBound(Data)
  Pic1.Line (i - 1, Data(i - 1))-(i, Data(i)), vbBlack
End Sub
Private Sub HScroll1_Scroll()
'Lblfft = "Frequency Cut-off:  " & Format(HScroll1.Value / 10.24, "0") & " %"
HScroll1_Change
End Sub
Private Sub Option1_Click(Index As Integer)
CmdCreateData_Click
Frame2.Visible = (Index = 1)
Frame1.Visible = (Index = 0)
If Index = 1 Then
  Me.Caption = "FFT Smoothing"
  Me.Caption = "Savitzky-Golay Smoothing"
End If
End Sub
Private Sub txtNumPoints_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
  If Val(txtNumPoints > 50) And Val(txtNumPoints < 5001) Then
    CmdCreateData_Click
  Else
    txtNumPoints = 1024
  End If
ElseIf KeyAscii <> 8 Then
  If Not IsNumeric(Chr(KeyAscii)) Then KeyAscii = 0
End If
End Sub
Private Sub txtNumPoints_LostFocus()
If Val(txtNumPoints) <> NP Then
  CmdCreateData_Click
End If
End Sub
Private Sub txtRandom_LostFocus()
If Not IsNumeric(txtRandom) Then
  MsgBox "You must enter a valid number for randomness"
  txtRandom.SetFocus
  Exit Sub
End If
If Val(txtRandom) < 0 Or Val(txtRandom) > 5 Then
  txtRandom = 1
End If
End Sub
Public Sub SavGolSmooth(Degree As Integer, CumulativeSmooth As Boolean)
'Savitzky_Golay Smoothing
'If SmoothCurrent is set to true, then the last smoothed data set will be smoothed,
'(i.e. The new smoothing will be cumulative over the last smoothing operation.  If
'SmoothCurrent is false, then the original Y-data will be smoothed, and the smoothedY array will
'be overwritten
'The Aavitzky-Golay smoothing algorithm essentialy fits the data to a second order polynomial
'within a moving data window.  It assumes that the data has a fixed spacing in the x direction,
'but does work even if this is not the case.
'For more info see:
'"Smoothing and Differentiation of Data by Simplified Least Squares Procedure",
'Abraham Savitzky and Marcel J. E. Golay, Analytical Chemistry, Vol. 36, No. 8, Page 1627 (1964)
'Degree 2 = 5 point
'Degree 3 = 7 point ...etc
Dim i As Integer, J As Integer
Dim TempSum As Double
On Error Resume Next
'Logging the data is useful if the data is always above zero, and spans
'several orders of magnitude
ReDim Temp(1 To NP) As Double
If ChkLog.Value = 1 Then
  If CumulativeSmooth Then
    For i = 1 To NP
      If SmoothedY(i) <> 0 Then
        SmoothedY(i) = Log(SmoothedY(i))
      Else
        SmoothedY(i) = 0.000001
      End If
    Next i
  Else
    For i = 1 To NP
      If DataY(i) <> 0 Then
        DataY(i) = Log(DataY(i))
      Else
        DataY(i) = 0.000001
      End If
    Next i
  End If
End If
If CumulativeSmooth = False Then
  'we cannot smooth too close to the data bounds
  For i = 1 To Degree
    SmoothedY(i) = DataY(i)
  Next i
  For i = NP - (Degree + 1) To NP
   SmoothedY(i) = DataY(i)
  Next i
  SmoothCount = 0
  For i = 1 + Degree To NP - Degree
    TempSum = DataY(i) * SGCoef(Degree - 1, 1)
    For J = 1 To Degree
      TempSum = TempSum + DataY(i - J) * (SGCoef(Degree - 1, J + 1))
      TempSum = TempSum + DataY(i + J) * (SGCoef(Degree - 1, J + 1))

    Next J
    SmoothedY(i) = TempSum / SGCoef(Degree - 1, 0)
  Next i
  'The last smoothed data will be used to create a new smoothed data set,
  'therefore the smoothing operations will be additive
  For i = 1 + Degree To NP - Degree
    TempSum = SmoothedY(i) * SGCoef(Degree - 1, 1)
    For J = 1 To Degree
      TempSum = TempSum + SmoothedY(i - J) * (SGCoef(Degree - 1, J + 1))
      TempSum = TempSum + SmoothedY(i + J) * (SGCoef(Degree - 1, J + 1))

    Next J
    SmoothedY(i) = TempSum / SGCoef(Degree - 1, 0)
  Next i
End If
If ChkLog.Value = 1 Then
  If CumulativeSmooth Then
    For i = 1 To NP
      SmoothedY(i) = Exp(SmoothedY(i))
    Next
  Else
    For i = 1 To NP
      DataY(i) = Exp(DataY(i))
      SmoothedY(i) = Exp(SmoothedY(i))
    Next
  End If
End If
SmoothCount = SmoothCount + 1
CmdSG2.Enabled = True
End Sub
Public Sub FFT(FR() As Double, FI() As Double, LnN As Integer, sign As Integer)
'From "Image Processing" by Jan Teuber
'The major weakness of the FFT algoirthm is the requirement that the number of data points be
'a power of 2.  To work around this, I find the nearest power of 2 that is below the number of data points,
'then I smooth the first 2^N points.  Then the remaining points are smoothed, with at least 32 points.
'The second set of smoothed data is appended to the first set
'This algorithm slows down very fast as the number of points gets higher
Dim nd2 As Integer
Dim i As Integer, J As Integer, k As Integer, l As Integer
Dim le As Integer, le1 As Integer
Dim ip As Integer, NP_FFT As Integer
Dim s As Double, ur As Double, ur1 As Double, ui As Double, wr As Double, wi As Double
Dim tr As Double, ti As Double, DivN As Double
  NP_FFT = 2 ^ LnN 'Number of points for use in FFT
  nd2 = NP_FFT / 2  'Half points
  J = 1
  For i = 1 To NP_FFT - 1
    If i < J Then
      s = FR(i)
      FR(i) = FR(J)
      FR(J) = s
      s = FI(i)
      FI(i) = FI(J)
      FI(J) = s
    End If
    k = nd2
    While k < J
      J = J - k
      k = k / 2
    Wend
    J = J + k
  Next i
  For l = 1 To LnN
    le = 2 ^ l
    le1 = le / 2
    ur = 1
    ui = 0
    wr = Cos(PI / le1)
    wi = sign * Sin(PI / le1)
    For J = 1 To le1
      i = J
      While (i <= NP_FFT)
        ip = i + le1
        tr = FR(ip) * ur - FI(ip) * ui
        ti = FR(ip) * ui + FI(ip) * ur
        FR(ip) = FR(i) - tr
        FI(ip) = FI(i) - ti
        FR(i) = FR(i) + tr
        FI(i) = FI(i) + ti
        i = i + le
      Wend
      ur1 = ur * wr - ui * wi
      ui = ur * wi + ui * wr
      ur = ur1
    Next
  Next   '{l - l
DivN = 1 / Sqr(NP_FFT)
 For i = 1 To NP_FFT
   FR(i) = FR(i) * DivN
   FI(i) = FI(i) * DivN
 Next i
End Sub